Shareware Grab Bag/Shareware Grab Bag.iso/090/byt86oct.arc/ALLOC.ARC/ALLOC2.MOD

Text File | 1985-07-12 | 5KB | 185 lines

IMPLEMENTATION MODULE Alloc2;

(* A storage allocator that tries to be safe about freed blocks.
   It detects attempts to access freed blocks by leaving "tombstones"
   in the heap.
   Copyright 1986 by Jonathan Amsterdam.  All Rights Reserved. *)

FROM SYSTEM IMPORT WORD, ADDRESS, TSIZE;
FROM MachineSpecific IMPORT getHeapBottom, getHeapTop, bytesPerWord,
    address, cardinal, addrLessThan, writeAddress;
FROM MyTerminal IMPORT fatal;

CONST maxIndex = 32767;

TYPE blockPtr = POINTER TO block;
     block = RECORD
         size:CARDINAL;  (* not including header *)
         CASE BOOLEAN OF
            TRUE: nextBlock: blockPtr;
         |  FALSE: contents:ARRAY[0..maxIndex] OF WORD;
         END;
         END;

VAR heapBottom, heapTop:ADDRESS;
    freeList:blockPtr;
    blockHeaderSize, minBlockSize:CARDINAL;

PROCEDURE init;
BEGIN
    heapBottom := getHeapBottom();
    heapTop := getHeapTop();
    blockHeaderSize := TSIZE(CARDINAL);
    minBlockSize := TSIZE(blockPtr) + blockHeaderSize;
    freeList := blockPtr(heapBottom);
    freeList^.size :=
     (cardinal(heapTop-heapBottom) DIV bytesPerWord) - blockHeaderSize + 1;
    freeList^.nextBlock := NIL;
END init;

PROCEDURE blockSize(blockp:blockPtr):CARDINAL;
BEGIN
    RETURN blockp^.size;
END blockSize;

PROCEDURE getWord(blockp:blockPtr; n:CARDINAL):WORD;
BEGIN
    tombstoneCheck(blockp);
    IF n < blockp^.size THEN
    RETURN blockp^.contents[n];
    ELSE
    fatal('getWord: out of bounds');
    END;
END getWord;

PROCEDURE setWord(blockp:blockPtr; n:CARDINAL; w:WORD);
BEGIN
    tombstoneCheck(blockp);
    IF n < blockp^.size THEN
    blockp^.contents[n] := w;
    ELSE
    fatal('setWord: out of bounds');
    END;
END setWord;

PROCEDURE allocate(nWords:CARDINAL):blockPtr;
VAR currBlock, prevBlock:blockPtr;
BEGIN
    currBlock := freeList;
    prevBlock := NIL;
    WHILE currBlock <> NIL DO
    IF nWords + minBlockSize < currBlock^.size THEN
        (* split the block into two, returning the 2nd part *)
        DEC(currBlock^.size, nWords+blockHeaderSize);
        INC(currBlock, bytesPerWord*(blockHeaderSize + currBlock^.size));
        currBlock^.size := nWords;
        RETURN currBlock;
    ELSIF nWords <= currBlock^.size THEN (* return the whole block *)
        link(prevBlock, currBlock^.nextBlock);
        RETURN currBlock;
    END;
    prevBlock := currBlock;
    currBlock := currBlock^.nextBlock;
    END;
    RETURN NIL;
END allocate;

PROCEDURE free(VAR freeBlock:blockPtr);
VAR currBlock, prevBlock, temp:blockPtr;
BEGIN
    IF NOT addrBetween(heapBottom, freeBlock, heapTop) THEN
    fatal("free: block not in heap");
    ELSIF freeBlock^.size = 0 THEN
    fatal("free: attempt to free an already freed block");
    ELSIF freeBlock^.size - blockHeaderSize < minBlockSize THEN
    (* don't attempt to incorporate the block into the freelist *)
    freeBlock^.size := 0;
    freeBlock := NIL;
    ELSE
    temp := freeBlock;
    INC(freeBlock, bytesPerWord*blockHeaderSize);
    freeBlock^.size := temp^.size - blockHeaderSize;
    temp^.size := 0;
    currBlock := freeList;
    prevBlock := NIL;
    WHILE (currBlock <> NIL) AND addrLessThan(currBlock, freeBlock) DO
        prevBlock := currBlock;
        currBlock := currBlock^.nextBlock;
    END;
    IF currBlock = NIL THEN
        freeBlock^.nextBlock := NIL;
        link(prevBlock, freeBlock);
    ELSE  (* freeBlock belongs just before currBlock *)
        freeBlock^.nextBlock := currBlock;
        link(prevBlock, freeBlock);
    END;
    tryToMerge(prevBlock, freeBlock, currBlock);
    freeBlock := NIL;
    END;
END free;

PROCEDURE tryToMerge(lowBlock, middleBlock, highBlock:blockPtr);
BEGIN
    IF adjacent(middleBlock, highBlock) THEN
    merge(middleBlock, highBlock);
    END;
    IF adjacent(lowBlock, middleBlock) THEN (* this should be impossible *)
    merge(lowBlock, middleBlock);
    END;
END tryToMerge;

PROCEDURE adjacent(lowerBlock, higherBlock:blockPtr):BOOLEAN;
BEGIN
  RETURN
    (lowerBlock <> NIL) AND
    (higherBlock <> NIL) AND
    (lowerBlock + address(bytesPerWord*(lowerBlock^.size + blockHeaderSize)) =
       higherBlock);
END adjacent;

PROCEDURE merge(lowerBlock, higherBlock:blockPtr);
BEGIN
    INC(lowerBlock^.size, higherBlock^.size + blockHeaderSize);
    lowerBlock^.nextBlock := higherBlock^.nextBlock;
END merge;

PROCEDURE link(prevBlock, linkBlock:blockPtr);
BEGIN
    IF prevBlock = NIL THEN
    freeList := linkBlock;
    ELSE
    prevBlock^.nextBlock := linkBlock;
    END;
END link;

PROCEDURE addrBetween(low, middle, high:ADDRESS):BOOLEAN;
BEGIN
    RETURN (addrLessThan(low, middle) OR (low = middle)) AND
       (addrLessThan(middle, high) OR (middle = high));
END addrBetween;

PROCEDURE tombstoneCheck(blockp:blockPtr);
BEGIN
    IF blockp^.size = 0 THEN
    fatal("attempt to access a freed block");
    END;
END tombstoneCheck;

PROCEDURE getFreeList():blockPtr;
(* for debugging only *)
BEGIN
    RETURN freeList;
END getFreeList;

BEGIN
    init;
END Alloc2.
reeList():blockPtr;
(* for debugging only *)
BEGIN
    RETURN freeList;
END getFreeList;

BEGIN
    init;
END All